package Flap::App::Web;
use Flap qw/-b Flap::App -m -r -s -w/;
use constant DEFAULT_VIEW_EXT => 'ft';
use constant ROUTING => [
    ['/'                        => {controller => 'Root', action => 'index'}],
    ['/:action'                 => {controller => 'Root'}],
    ['/:controller/'            => {action => 'index'}],
    ['/:controller/:action'     => {}],
    ['/:controller/:action/:id' => {}],
];
use constant ROUTING_ARGS => {
    controller => qr%(?:[a-z][0-9a-z_]*/)*[a-z][0-9a-z_]*%,
    action     => qr/[a-z][0-9a-z_]*/,
    id         => qr/\d+/,
};
use constant STR2HTM => {
    "\n"   => '<br />',
    "\r"   => '<br />',
    "\r\n" => '<br />',
    '"'    => '&quot;',
    '&'    => '&amp;',
    "'"    => '&#39;',
    '('    => '&#40;',
    ')'    => '&#41;',
    '<'    => '&lt;',
    '>'    => '&gt;',
};
use constant HTM2STR => {reverse %{__PACKAGE__->STR2HTM}};
our $PSGI_REQ;

__PACKAGE__->_mk_accessors_(qw/error request response view/);
*req = \&request;
*res = \&response;

sub DESTROY {
    my $c = shift;
    $c->psgi_end if (my $psgi_end = $PSGI_REQ && $c->req eq $PSGI_REQ);
    undef %$c;
    $c->SUPER::DESTROY(@_);
    return if !$psgi_end;
    $c->project->end;
    $PSGI_REQ = undef;
}

sub action { shift->route->{action} }

sub args { shift->route->{args} }

sub controller {
    my $c = shift;
    return $c->controller($c->route->{controller}) if !@_;
    my $ctl = $c->Controller.'::'.shift;
    (my $pm = "$ctl.pm") =~ s%::%/%g;
    ($::INC{$pm} || (-f $c->app_root."/lib/$pm") && (require $pm)) ? $ctl : undef;
}

sub debug {
    return undef if !$::ENV{FLAP_DEBUG};
    my $c = shift;
    return 1 if !@_;
    if(!ref $_[0]){
        print STDERR $_[0] eq '=' ? $c->Util->debug_line('=') : "[DEBUG] $_[0]\n";
    }else{
        (my $msg = ${$_[0]}) =~ s/\s+\z//;
        $msg =~ s/\n/\n - /g;
        print STDERR " - $msg\n";
    }
    $c;
}

sub default_config { shift->project->config->App->Web }

sub default_view {
    my $c = shift;
    $c->controller->PATH.$c->action.'.'.$c->DEFAULT_VIEW_EXT;
}

sub dispatch {
    my($c, $path, $opt) = (shift, shift, shift || {});
    
    $c->{error} = undef;
    my $st = eval{
        my $r = $c->routing($path) || return $c->http_error(404);
        $c->res->status(200);
        $c->route($r);
        $c->_dispatch($r, $opt);
    };
    if($@){
        $c->{error} = $@;
        $c->res->status(500);
        return !1;
    }
    $st;
}

sub _dispatch {
    my($c, $r, $opt) = @_;
    my $debug = $::ENV{FLAP_DEBUG};
    
    my $dc = $c->_global_->{dispatch_cache}{$r->{controller}}
     ||= $c->dispatch_cache($r->{controller});
    
    $c->debug('dispatch') if $debug;
    if($dc->{begin} && $opt->{begin}){
        $c->debug(\"$dc->{begin}->begin") if $debug;
        $dc->{begin}->begin($c) || return !1;
    }
    if($dc->{auto} && $opt->{auto}){
        foreach(@{$dc->{auto}}){
            $c->debug(\"$_->auto") if $debug;
            $_->auto($c) || return !1;
        }
    }
    my($ctl, $act) = ($c->controller($r->{controller}), $r->{action});
    $c->debug(\"$ctl->$act") if $debug;
    $ctl->$act($c);
    if($dc->{end} && $opt->{end}){
        $c->debug(\"$dc->{end}->end") if $debug;
        $dc->{end}->end($c);
    }
    1;
}

sub dispatch_cache {
    my($c, $ctl) = @_;
    my @ctl = split /::/, $ctl;
    $ctl[$_] = $ctl[$_ - 1].'::'.$ctl[$_] for 1 .. $#ctl;
    unshift @ctl, 'Root' if $ctl ne 'Root';
    
    my %dc;
    foreach($c->Controller, map{ $c->controller($_) } @ctl){
        $dc{begin} = $_ if $_->_code_('begin');
        push @{$dc{auto} ||= []}, $_ if $_->_code_('auto');
        $dc{end} = $_ if $_->_code_('end');
    }
    \%dc;
}

sub finalize {
    my $c = shift;
    
    $c->debug('finalize') if $::ENV{FLAP_DEBUG};
    if((my $st = $c->res->status) !~ /^3/){
        $c->res->content_type($c->ua->content_type) if !$c->res->content_type;
        if(!defined $c->res->{body}){
            if($st == 200 && !$c->render){
                warn $c->error;
                $c->res->status($st = 500);
            }
            if($st != 200 && !$c->view("/$st.".$c->DEFAULT_VIEW_EXT)->render){
                require HTTP::Status;
                $c->res->body("$st ".HTTP::Status::status_message($st));
            }
        }
    }
    
    $c->res->finalize;
}

sub html {
    my $c = shift;
    my $r = ref $_[0] ? shift : do{ \(my $s = shift) };
    $$r =~ s/(\r\n?|[\n"&'()<>])/$c->STR2HTM->{$1}/eg;
    $$r;
}

sub http_error {
    my($c, $st) = @_;
    my($file, $line) = (caller)[1, 2];
    $c->res->status($st);
    $c->error("$st at $file line $line.");
    !1;
}

sub include_path {
    my $c = shift;
    $c->{include_path} ||= [map{ "$_/view" } $c->app_root, $c->project_root];
}

sub locate_view {
    my $c = shift;
    my $v = shift || die 'No view';
    die qq{View "$v" is not absolute} if substr($v, 0, 1) ne '/';
    my $sfx = shift || '';
    my $lvc = $c->_global_->{locate_view_cache} ||= {};
    my $loc = $lvc->{$v.$sfx} || do{
        my $loc;
        foreach(@{$c->include_path}){
            last if $sfx && -f "$_$v$sfx" && ($loc = [$_]);
            last if -f $_.$v && ($loc = [$_, $sfx ? $v : undef]);
        }
        return undef if !$loc;
        $loc->[0] = $c->_symbol_($loc->[0]);
        $lvc->{$v.$sfx} = $loc;
    };
    [${$loc->[0]}, $loc->[1] || $v.$sfx];
}

sub log {
    my $c = shift;
    $c->_log($c->req, @_);
}

sub _log {
    my($class, $req) = (shift, shift);
    $class->debug(\"$_[1]") if $::ENV{FLAP_DEBUG};
    $class->project->log->write(
        $class->app_name,
        shift,
        shift,
        $req->headers->as_string,
        ($req->method eq 'POST' ? (
            $req->content_length <= 4096 ? $req->_body_parser->raw_body : '...'
        ) : ''),
    );
}

sub new {
    my $c = shift->_new_({});
    $c->req($c->Request->new(shift));
    $c->res($c->Response->new);
    $c;
}

sub open_view {
    my $c = shift;
    my $v = $c->view || $c->default_view;
    my $loc = $c->locate_view($v, $c->ua->view_suffix) || return !$c->error(qq{Can't locate "$v"});
    my $vc = $c->view_class($loc);
    $c->debug(\qq{$vc->open("$loc->[0]$loc->[1]")}) if $::ENV{FLAP_DEBUG};
    $vc->open($c, $loc);
}

sub path {
    my $c = shift;
    $c->{path} ||= do{
        my $pfx = $c->uri_prefix;
        (my $path = $c->req->path) =~ s%^\Q$pfx\E%%;
        $path;
    };
}

sub prepare {
    my $class = shift;
    my $proj = $class->project;
    
    $proj->begin;
    $proj->log->print('');
    $proj->end;
}

sub project_options {
    my $class = shift;
    return {
        dbh_auto_reconnect => 1,
        trace => {
            exclude => qr/^(?:Plack|\(eval\)|Try::Tiny)|:_\w*\z/,
            warn    => sub{ $class->_log($PSGI_REQ, '__WARN__', @_); },
        },
    };
}

sub psgi {
    my $class = shift;
    $class->prepare;
    
    sub{
        my $c;
        eval{
            $class->project->begin($class->project_options);
            $c = $class->new(@_);
            $PSGI_REQ = $c->req;
            
            $c->psgi_begin;
            $c->dispatch($c->path, {begin => 1, auto => 1, end => 1});
            $c->log('__DIE__', $c->error) if $c->res->status == 500;
            $c->finalize;
        } || do{
            $class->_log($PSGI_REQ, '__DIE__', $@);
            [500, [], ['500 Internal Server Error']];
        }
    };
}

sub psgi_begin { shift->debug('=')->debug('psgi_begin') if $::ENV{FLAP_DEBUG} }

sub psgi_end { shift->debug('psgi_end') if $::ENV{FLAP_DEBUG} }

sub render {
    my $c = shift;
    my $vh = $c->open_view || return;
    $vh->render(shift || \($c->res->{body} = ''));
    $vh->close;
}

sub route {
    my $c = shift;
    return $c->{route} || die 'No route' if !@_;
    $c->{route} = shift;
    $c;
}

sub routing {
    my($c, $path) = @_;
    my $debug = $::ENV{FLAP_DEBUG};
    
    $c->debug(qq{routing: "$path"}) if $debug;
    foreach(@{$c->_global_->{routing_cache} ||= $c->routing_cache}){
        my %m;
        (@m{@{$_->[1]}} = ($path =~ $_->[0])) || next;
        $c->debug(\('matched as '.$c->Util->dump_inline($_->[2]))) if $debug;
        
        my $r = $c->routing_matched($_->[2], \%m, $path);
        next if !$r && (!$debug || $c->debug(\'$c->routing_matched failed.'));
        
        my $ctl = $c->controller($r->{controller});
        next if !$ctl && (!$debug || $c->debug(\qq{no controller for "$r->{controller}"}));
        
        my $code = $ctl->can($r->{action});
        my $arg = $code && $ctl->ACTION_ARGS->{$code};
        next if !$arg && (!$debug || $c->debug(\qq{no :Action "$r->{action}" via "$ctl"}));
        
        if(my($ng) = grep{ !$arg->{$_} } keys %{$r->{args}}){
            next if !$debug || $c->debug(\qq{args "$ng" not allowed at "$ctl->$r->{action}"});
        }
        
        $c->debug(\('found '.$c->Util->dump_inline($r))) if $debug;
        return $r;
    }
    $c->debug(\'no route found.') if $debug;
    undef;
}

sub routing_cache {
    my $c = shift;
    my @rc;
    foreach(@{$c->ROUTING}){
        my($path, $r) = @$_;
        my(@arg, %arg);
        (my $ptn = $path) =~ s%:(\w+)%
            my $arg = $c->ROUTING_ARGS->{$1} || die qq{ROUTING_ARGS "$1" is not defined};
            push @arg, $1;
            $arg{$1} = 1;
            qr/($arg)/;
        %eg;
        foreach(qw/controller action/){
            my $msg = ($r->{$_} && $arg{$_}) ? 'duplicate' :
                (!$r->{$_} && !$arg{$_}) ? 'missing' : next;
            die "Invalid ROUTING: $msg $_ for ".$c->Util->dump_inline([$path => $r]);
        }
        push @rc, [qr/^$ptn\z/, \@arg, $_];
    }
    \@rc;
}

sub routing_matched {
    my($c, $r, $m) = @_;
    $r = {%{$r->[1]}, args => $m};
    
    if(exists $m->{action}){
        return undef if $m->{action} eq 'index';
        $r->{action} = delete $m->{action};
    }
    if(exists $m->{controller}){
        return undef if $m->{controller} eq 'root';
        $r->{controller} = $c->Util->path2class(delete $m->{controller}) || return undef;
    }
    $r;
}

sub stash {
    my $c = shift;
    my $s = $c->{stash} ||= {};
    return $s if !@_;
    return $s->{+shift} if @_ == 1;
    while(@_){
        my $k = shift;
        $s->{$k} = shift;
    }
    $c;
}

sub uri_for {
    my($c, $uri, $q) = @_;
    $uri = $c->uri_prefix.$uri if substr($uri, 0, 1) eq '/';
    if($q){
        die 'Invalid query' if ref $q ne 'HASH';
        $uri .= (index($uri, '?') >= 0 ? '&' : '?').$c->Util->uri_escape($q) if %$q;
    }
    $uri;
}

sub uri_prefix { '' }

sub user_agent {
    my $c = shift;
    $c->{user_agent} ||= $c->UserAgent->new($c);
}
*ua = \&user_agent;

sub view_class { shift->View->FT }

1;
